home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Taifun / Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip / Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf / PCQ / Source / Stanfuncs.p < prev    next >
Text File  |  1989-03-31  |  4KB  |  145 lines
  1. external;
  2.  
  3. {
  4.     Stanfuncs.p (of PCQ Pascal)
  5.     Copyright (c) 1989 Patrick Quaid
  6.  
  7.     This module handles all the standard functions.
  8. }
  9.  
  10. const
  11. {$I "pasconst.i"}
  12.  
  13. type
  14.  
  15. {$I "pastype.i"}
  16.  
  17. var
  18.  
  19. {$I "pasvar.i"}
  20.  
  21.     function loadaddress(): integer;
  22.         forward;
  23.     function match(s : integer): boolean;
  24.         forward;
  25.     function typecheck(t1, t2 : integer): boolean;
  26.         forward;
  27.     procedure error(s : string);
  28.         forward;
  29.     function expression() : integer;
  30.         forward;
  31.     function numbertype(i : integer): boolean;
  32.         forward;
  33.     procedure needleftparent;
  34.         forward;
  35.     procedure needrightparent;
  36.         forward;
  37.     procedure neednumber;
  38.         forward;
  39.     function getlabel(): integer;
  40.         forward;
  41.     procedure printlabel(l : integer);
  42.         forward;
  43.     function suffix(s : integer) : char;
  44.         forward;
  45.  
  46. procedure doopen(nametype, accessmode : integer);
  47.  
  48. {
  49.     This routine handles both open and reopen, depending on the
  50. accessmode sent to it.  This is just passed on to the DOS routine.
  51. }
  52.  
  53. var
  54.     filetype    : integer;
  55.     bufsize    : integer;
  56. begin
  57.     if typecheck(nametype, stringtype) then begin
  58.     writeln(output, "\tmove.l\td0,-(sp)");
  59.     if match(comma1) then begin
  60.         filetype := loadaddress();
  61.         if idents[filetype].offset = vfile then begin
  62.         writeln(output, "\tmove.l\t(sp)+,d0");
  63.         writeln(output, "\tmove.l\t#", accessmode, ',d2');
  64.         bufsize := idents[filetype].vtype;
  65.         bufsize := idents[bufsize].size;
  66.         writeln(output, "\tmove.l\t#", bufsize, ',8(a0)');
  67.         writeln(output, "\tjsr\t_p%open");
  68.         end else
  69.         error("Need a file variable");
  70.     end else
  71.         error("Expecting a comma");
  72.     end else
  73.     error("Expecting a string (the file name).");
  74. end;
  75.  
  76. procedure stdfunc(varindex : integer);
  77.  
  78. {
  79.     This routine handles all the standard functions.  All but
  80. open and reopen are handled in-line.
  81. }
  82.  
  83. var
  84.     exprtype    : integer;
  85.     lab        : integer;
  86. begin
  87.     needleftparent;
  88.     if idents[varindex].offset < 10 then
  89.     exprtype := expression();
  90.     if idents[varindex].offset = 1 then begin { ord }
  91.     if idents[exprtype].offset = vordinal then begin
  92.         if idents[exprtype].size = 1 then
  93.         idents[varindex].vtype := bytetype
  94.         else if idents[exprtype].size = 2 then
  95.         idents[varindex].vtype := shorttype
  96.         else
  97.         idents[varindex].vtype := inttype;
  98.     end else
  99.         error("Must be a simple type");
  100.     end else if idents[varindex].offset = 2 then begin { chr }
  101.     if not numbertype(exprtype) then
  102.         neednumber;
  103.     end else if idents[varindex].offset = 3 then begin { odd }
  104.     if not numbertype(exprtype) then
  105.         neednumber;
  106.     writeln(output, "\tand.", suffix(idents[exprtype].size), "\t#1,d0");
  107.     writeln(output, "\tsne\td0");
  108.     end else if idents[varindex].offset = 4 then begin { abs }
  109.     if not numbertype(exprtype) then
  110.         neednumber;
  111.     lab := getlabel();
  112.     writeln(output, "\ttst.", suffix(idents[exprtype].size), "\td0");
  113.     write(output, "\tbpl.s\t");
  114.     printlabel(lab);
  115.     writeln(output);
  116.     writeln(output, "\tneg.", suffix(idents[exprtype].size), "\td0");
  117.     printlabel(lab);
  118.     writeln(output);
  119.     end else if idents[varindex].offset = 5 then begin { succ }
  120.     if idents[exprtype].offset <> vordinal then
  121.         error("expecting an ordinal type");
  122.     writeln(output, "\taddq.", suffix(idents[exprtype].size), "\t#1,d0");
  123.     idents[varindex].vtype := exprtype;
  124.     end else if idents[varindex].offset = 6 then begin { pred }
  125.     if idents[exprtype].offset <> vordinal then
  126.         error("expecting an ordinal type");
  127.     writeln(output, "\tsubq.", suffix(idents[exprtype].size), "\t#1,d0");
  128.     idents[varindex].vtype := exprtype;
  129.     end else if idents[varindex].offset = 7 then begin { reopen }
  130.     doopen(exprtype, 1005)
  131.     end else if idents[varindex].offset = 8 then begin { open }
  132.     doopen(exprtype, 1006)
  133.     end else if idents[varindex].offset = 9 then begin { eof }
  134.     if idents[exprtype].offset = vfile then begin
  135.         writeln(output, "\tmove.l\td0,a0");
  136.         writeln(output, "\tmove.b\t12(a0),d0");
  137.     end else
  138.         error("Expecting a file type");
  139.     end else if idents[varindex].offset = 10 then begin { adr }
  140.     exprtype := loadaddress();
  141.     writeln(output, "\tmove.l\ta0,d0");
  142.     end;
  143.     needrightparent;
  144. end;
  145.